home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
fortran
/
libry51.zip
/
LIBRY5A.DOC
< prev
next >
Wrap
Text File
|
1989-11-10
|
7KB
|
277 lines
.de
.pa
EXAMPLE USING ASCII FILE PROCEDURES
$STORAGE:2
PROGRAM EXAMPLE1
C
C IN THIS EXAMPLE ONE FILE WILL BE COPIED INTO ANOTHER
C
IMPLICIT INTEGER*2 (I-N)
CHARACTER CBUF*80,INFILE*12,OUTFILE*12,ANS
DATA LINES/0/
C
CALL WRTTY('EXMPL/V1.0: example using file procedures<')
CALL WRTTY(' (copying one file into another)<')
C
C FETCH FILE NAMES FROM RUNTIME STRING
C
CALL RRPAR(1,INFILE)
CALL RRPAR(2,OUTFILE)
C
C CHECK FOR MISSING FILE NAMES
C
IF(INFILE.NE.' '.AND.OUTFILE.NE.' ') GO TO 100
CALL WRTTY('missing file names... try something like<')
CALL WRTTY(' EXMPL infile outfile<')
GO TO 999
C
C OPEN INFILE (NOTE: NEW='-1')
C
100 CALL FOPEN1(INFILE,-1,IERR)
IF(IERR.EQ.0) GO TO 110
CALL WRTTY('unable to access infile<')
GO TO 999
C
C OPEN OUTFILE, FIRST CHECK FOR ALREADY EXIST (NOTE: NEW=-1)
C IF YOU DON'T CARE TO CHECK FOR OVERWRITE JUST SET NEW=0
C
110 CALL FOPEN2(OUTFILE,-1,IERR)
IF(IERR.NE.0) GO TO 120
CALL FCLOS2
C
111 CALL WRTTY('outfile already exists... overwrite?(Y/N)_')
CALL READ1(ANS)
IF(ANS.EQ.'Y') GO TO 112
IF(ANS.EQ.'N') GO TO 900
CALL BEEP
CALL CLEAR1
GO TO 111
C
112 CALL CLEAR1
CALL FOPEN2(OUTFILE,0,IERR)
IF(IERR.NE.0) GO TO 900
GO TO 200
C
C OPEN OUTFILE, CREATE (NOTE: NEW=1)
C
120 CALL FOPEN2(OUTFILE,1,IERR)
IF(IERR.EQ.0) GO TO 200
CALL WRTTY('unable to access outfile<')
GO TO 900
C
C READ INFILE
C
200 CALL FREAD1(CBUF,80,LREC,IERR,IEND)
IF(IERR.NE.0) GO TO 400
IF(IEND.NE.0) GO TO 300
LINES=LINES+1
C
C COPY TO OUTFILE
C
CALL FWRIT2(CBUF,LREC,IERR)
IF(IERR.NE.0) GO TO 500
GO TO 200
C
C END OUTFILE
C
300 CALL FENDF2
WRITE(CBUF,3000) LINES
3000 FORMAT('lines copied ',I5,'<')
CALL WRTTY(CBUF)
GO TO 900
C
C READ ERROR
C
400 WRITE(CBUF,4000) LINES
4000 FORMAT('infile read error at line ',I5,'<')
CALL WRTTY(CBUF)
GO TO 900
C
C WRITE ERROR
C
500 WRITE(CBUF,5000) LINES
5000 FORMAT('outfile write error at line ',I5,'<')
CALL WRTTY(CBUF)
C
C CLOSE FILES
C
900 CALL FCLOS2
CALL FCLOS1
999 STOP
END
.pa
EXAMPLE USING DIRECTORY SEARCH PROCEDURES
$STORAGE:2
PROGRAM EXAMPLE2
C
C IN THIS EXAMPLE THE DIRECTORY SEARCH ROUTINES WILL BE ILLUSTRATED
C
IMPLICIT INTEGER*2 (I-N)
CHARACTER NAME*12,CBUF*3
C
100 CALL WRTTY('<')
CALL WRTTY('enter file mask _')
CALL READC(NAME,12,IERR)
IF(IERR.NE.0) GO TO 999
IF(NBUFC1(NAME,12).EQ.0) GO TO 999
C
C SET DIRECTORY SEARCH IN DOS
C
NFILE=0
CALL DIRSET(NAME)
C
C NO AVAILABLE FILES
C
IF(NAME.EQ.' ') THEN
IF(NFILE.NE.0) GO TO 999
CALL WRTTY('Sorry, there are no files matching this mask.<')
GO TO 100
ENDIF
C
CALL WRTTY('The matching files are:<')
GO TO 120
C
C GET NEXT DIRECTORY ENTRY
C
110 CALL DIRNXT(NAME)
IF(NAME.EQ.' ') GO TO 100
C
C LIST FILE NAME
C
120 NFILE=NFILE+1
WRITE(CBUF,'(I3)') NFILE
CALL WRTTY(CBUF//' '//NAME//'<')
GO TO 110
C
999 STOP
END
.pa
EXAMPLE USING BINARY FILE PROCEDURES
$STORAGE:2
PROGRAM EXAMPLE3
C
C the purpose of this program is to fix up a totally messed up file
C
IMPLICIT INTEGER*2(I-N)
INTEGER*4 LREAD,LWRIT
PARAMETER (LBUF=4096)
CHARACTER CBUF(LBUF),DBUF(LBUF),C80*80
DATA JBUF,LREAD,LWRIT/3*0/
C
CALL WRTTY('opening input file<')
CALL BOPEN('LOST'C,0,IHAND1,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('unable to open input file<')
GO TO 999
ENDIF
C
CALL WRTTY('purging old output file<')
CALL BPURGE('FOUND'C)
C
CALL WRTTY('creating new output file<')
CALL BCREAT('FOUND'C,0,IHAND2,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('unable to create new output file<')
CALL BCLOSE(IHAND1)
GO TO 999
ENDIF
C
100 CALL BREAD(IHAND1,LBUF,CBUF,KBUF,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('error reading input file<')
CALL BCLOSE(IHAND1)
CALL BCLOSE(IHAND2)
GO TO 999
ENDIF
LREAD=LREAD+INT4(KBUF)
CALL CLEAR1
WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
CALL WRTTY(C80)
WRITE(C80,'(A,I8,1H_)') ' bytes written=',LWRIT
CALL WRTTY(C80)
C
IBUF=0
110 IBUF=IBUF+1
IF(IBUF.GT.KBUF) GO TO 120
C
JBUF=JBUF+1
IF(JBUF.GT.LBUF) THEN
CALL BWRITE(IHAND2,LBUF,DBUF,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('error writing output file<')
CALL BCLOSE(IHAND1)
CALL BCLOSE(IHAND2)
GO TO 999
ENDIF
LWRIT=LWRIT+INT4(LBUF)
CALL CLEAR1
WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
CALL WRTTY(C80)
WRITE(C80,'(A,I8,1H_)') ' bytes written=',LWRIT
CALL WRTTY(C80)
JBUF=1
ENDIF
C
IF(CBUF(IBUF).EQ.CHAR(13)) THEN
DBUF(JBUF)=CBUF(IBUF)
JBUF=JBUF+1
IF(JBUF.GT.LBUF) THEN
CALL BWRITE(IHAND2,LBUF,DBUF,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('error writing output file<')
CALL BCLOSE(IHAND1)
CALL BCLOSE(IHAND2)
GO TO 999
ENDIF
LWRIT=LWRIT+INT4(LBUF)
CALL CLEAR1
WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
CALL WRTTY(C80)
WRITE(C80,'(A,I8,1H_)') ' bytes written=',LWRIT
CALL WRTTY(C80)
JBUF=1
ENDIF
DBUF(JBUF)=CHAR(10)
ELSE
IF(CBUF(IBUF).GE.CHAR(32).AND.CBUF(IBUF).LE.CHAR(127)) THEN
DBUF(JBUF)=CBUF(IBUF)
ELSE
DBUF(JBUF)=' '
ENDIF
ENDIF
GO TO 110
C
120 IF(KBUF.EQ.LBUF) GO TO 100
C
IF(JBUF.GT.0) THEN
CALL BWRITE(IHAND2,JBUF,DBUF,IERR)
IF(IERR.NE.0) THEN
CALL WRTTY('error writing output file<')
CALL BCLOSE(IHAND1)
CALL BCLOSE(IHAND2)
GO TO 999
ENDIF
LWRIT=LWRIT+INT4(JBUF)
CALL CLEAR1
WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
CALL WRTTY(C80)
WRITE(C80,'(A,I8,1H_)') ' bytes written=',LWRIT
CALL WRTTY(C80)
ENDIF
CALL WRTTY('<')
C
CALL WRTTY('closing input file<')
CALL BCLOSE(IHAND1)
CALL WRTTY('closing output file<')
CALL BCLOSE(IHAND2)
C
999 STOP
END
.ee